{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module X (X, runX, moveTo, string, clear) where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.State
import Data.Bits
import Data.IORef
import Data.Maybe
import Graphics.X11.Xft
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrender
import System.Exit
import System.IO

newtype X a = X { unX :: StateT XSt IO a }
  deriving (Functor, Monad, MonadIO, MonadState XSt)

data XSt = XSt
    { display :: Display
    , cursor  :: Int
    , font    :: XftFont
    , width   :: Int
    , height  :: Int
    , pixmap  :: Pixmap
    }

modifyCursor :: (Int -> Int) -> XSt -> XSt
modifyCursor f st = st { cursor = f (cursor st) }

runX :: String              -- ^ window title
     -> Int                 -- ^ x
     -> Int                 -- ^ y
     -> Maybe Int           -- ^ height, defaults to font height
     -> Maybe Int           -- ^ width, defaults to screen width
     -> String              -- ^ XLFD font identifier
     -> (XEventPtr -> X ()) -- ^ X event handler
     -> IO ()

runX title x y w' h' xlfd proc = do
    dpy   <- openDisplay ""
    let dflt = defaultScreen dpy
        scr  = defaultScreenOfDisplay dpy
        dpth = defaultDepthOfScreen scr
        vis  = defaultVisualOfScreen scr
    rootw <- rootWindow dpy dflt
    fn <- xftFontOpen dpy scr xlfd
    fh <- xftfont_height fn
    let w = fromMaybe (fi $ widthOfScreen scr) w'
        h = fromMaybe (fh + 4) h'
    win   <- allocaSetWindowAttributes $ \attrs -> do
       set_override_redirect attrs True
       set_event_mask attrs (exposureMask .|. keyPressMask)
       createWindow dpy rootw (fi x) (fi y) (fi w) (fi h) 0 dpth inputOutput vis
           (cWOverrideRedirect .|.  cWEventMask) attrs
    setTextProperty dpy win title wM_NAME
    mapWindow dpy win
    gs <- grabKeyboard' dpy win 1000 1000
    unless (gs == grabSuccess) $ do
        hPutStrLn stderr $ title ++ ": grabbing keyboard failed"
        exitWith (ExitFailure 1)
    gc  <- createGC dpy win
    pix <- createPixmap dpy win (fi w) (fi h) dpth

    sRef <- newIORef $ XSt dpy 0 fn w h pix

    handle discard $ allocaXEvent $ \e -> forever $ do
        nextEvent dpy e
        s  <- readIORef sRef
        s' <- execStateT (unX (proc e)) s
        writeIORef sRef s'
        copyArea dpy pix win gc 0 0 (fi w) (fi h) 0 0
        sync dpy False

    freePixmap dpy pix
    freeGC dpy gc
    xftFontClose dpy fn
    ungrabKeyboard dpy currentTime
  where discard (_ :: AsyncException) = return ()

moveTo :: Int -> X ()
moveTo = modify . modifyCursor . const

clear :: String -> X ()
clear col = do
    dpy <- gets display
    pix <- gets pixmap
    h   <- gets height
    w   <- gets width
    let dflt = defaultScreen dpy
        vis  = defaultVisual dpy dflt
        cmap = defaultColormap dpy dflt
    liftIO $ withXftDraw dpy pix vis cmap $ \xftDraw ->
        withXftColorName dpy vis cmap col $ \xftColor ->
            xftDrawRect xftDraw xftColor (0 :: Int) (0 :: Int) w h
    modify (modifyCursor (const 0))

string :: String -> String -> X Bool
string _   "" = return True
string col s  = do
    dpy <- gets display
    pix <- gets pixmap
    cx  <- gets cursor
    fn  <- gets font
    w   <- gets width
    fontHeight <- liftIO $ xftfont_height fn
    glyph      <- liftIO $ xftTextExtents dpy fn s
    let dflt  = defaultScreen dpy
        vis   = defaultVisual dpy dflt
        cmap  = defaultColormap dpy dflt
        right = cx - xglyphinfo_x glyph + xglyphinfo_width glyph 
    if right <= w then do
        liftIO $ withXftDraw dpy pix vis cmap $ \xftDraw ->
            withXftColorName dpy vis cmap col $ \xftColor ->
                xftDrawString xftDraw xftColor fn cx fontHeight s
        modify (modifyCursor (+xglyphinfo_xOff glyph))
        return True
      else return False

grabKeyboard' :: Display -> Window -> Int -> Int -> IO GrabStatus

grabKeyboard' dpy win 1 _ =
    grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime

grabKeyboard' dpy win n s = do
    gs <- grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
    if gs /= grabSuccess then do
        threadDelay s
        grabKeyboard' dpy win (n - 1) s
      else return gs

fi :: (Integral b, Num a) => b -> a
fi = fromIntegral

